00010	C***** SUBRS.  SAVIT, LISTP, FIXUP, KSIG
00055	
00100		SUBROUTINE SAVIT
00200		IMPLICIT INTEGER(A-Q,S-Z)
00300		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
00400		COMMON/DL/X22,SAVER,NAME/POSI/STFF(8),JJB,POS
00500		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
00600		COMMON/ALF/INP(72),ML/XRN/RN(4000)/DPY/ST(4000),WDS(250),MEDIT,IGO
00700		COMMON /STF/RSTFAC(8),RSTJC/PTR/PWDS(250),ITEM,L,I,IX
00800		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00900		EQUIVALENCE (INP2,INP(2)),(ST2,ST(2))
01000	C  'SAME' WILL REPEAT CURRENT NAME.  BLANK WILL USE FOR21.DAT.
01100		IF(SAVER.GE.0)GO TO 10
01200	101	REWIND 21
01300		SAVER=7
01400		GO TO 102
01500	3	FORMAT(' WRITE OVER ',A5,'.DAT?  ',$)
01600	1	FORMAT(I,24F)
01700	2	TYPE 3,NAME
01800		ACCEPT FA1,L
01900		IF(L.NE.'N')GO TO 4
01990	10	IF(INP2.NE.'M')GO TO 11
01992		INP2='B'
01994		GO TO 4
02000	11	TYPE 21
02100		L=NAME
02200		ACCEPT FA5,NAME
02300	C 99 WILL BACK UP.
02400		IF(NAME.NE.'99')GO TO 40
02500		NAME=L
02600		RETURN
02610	40	IF(NAME.NE.'SAME')GO TO 43
02655		NAME=L
02677		GO TO 4
02700	43	IF(LOOKD(NAME))GO TO 2
02800	C  JUMP BACK IF FILE NAME ALREADY ON DSK
02900	4	REWIND 21
03000		IF(NAME.EQ.' ')GO TO 41
03100		CALL OFILE(21,NAME)
03200		GO TO 42
03300	41	NAME=L
03400	42	IF(INP2.EQ.'D')GO TO 202
03500	C   SB=SAVE BIG;  SD=SAVE DPY ONLY; SM=SB WITH SAME NAME
03600	102	WRITE(21)ITEM,I
03700		1,(PWDS(L),L=1,ITEM+1),(RN(L),L=1,I-1),ISCR,(V(L),L=1,ISCR),
03800		1 LCNT,(LIST(L),L=1,LCNT),RSTFAC,STFF,L
03900		WRITE(21)RSTFAC,STFF,L
03910	C  TAKE OUT ABOVE NEXT YEAR (12/73)
04000		IF(INP2.NE.'B')GO TO 1001
04100		WRITE(21)ST2,(ST(L),L=1,ST2+2),(WDS(L),L=1,ITEM+1)
04200	1001	END FILE 21
04300		IF(INP(1).EQ.'S'.AND.NAME.EQ.' ')TYPE 5600
04400	C   GO BACK IF THE SAVER WROTE THE FILE
04500		RETURN
04600	202	WRITE(21),ST2,(ST(L),L=1,ST2+2)
04700		GO TO 1001
04800	C   WRITES DPY BUFFER ONLY.
04900	5600	FORMAT(' DISPLAY SAVED IN ''FOR21.DAT'''/)
05000	56	FORMAT(/1XA5,'  TYPE FOR ITEM #',I3,I/)
05100	21	FORMAT(' FILE NAME?'/)
05200		END
05300	
05400		SUBROUTINE LISTP(LST)
05500		IMPLICIT INTEGER(A-Q,S-Z)
05600		REAL PWDS
05700		DIMENSION LST(13)
05800		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
05900		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
06000		COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
06100		EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3))
06200	
06300		IF(RJB.EQ.0)RJB=1.
06400		IF(JC.EQ.0)JC=ITEM
06500		JY=5
06600		IF(JD.NE.0)JY=3
06700		DO 6334 L=IFIX(RJB),JC
06800		X=PWDS(L)
06900		Y=RN(X)+2+X
07000		X=X+1
07100		K=RN(X)
07200		IF(K.EQ.50)K=13
07300		IF(K.EQ.30)K=12
07400		IF(K.EQ.18)K=11
07500	6334	WRITE(JY,6333),L,LST(K),(RN(K),K=X,Y)
07600		IF(JY.NE.3)RETURN
07700	C  333, N1, N2, N3  TYPES ITEM LIST. N1=1ST, N2=LAST, N3=TO LPT?
07800		IF(JE.NE.0)WRITE(JY, 63331),PWDS
07900	CC	DO 2055 K=1,ITEM+1
08000	CC2055	PWDS(K)=WDS(K)
08100	CC	WRITE(JY, 63331),PWDS
08200		RETURN
08300	CC R ARRAY REMOVED 12/73	WRITE(JY, 63331),R
08400	C  LEAVE THIS HERE SO WRITE(JY, OF R IS POSSIBLE IN DDT
08500	CC1055	END FILE JY
08600	CCCC	CALL SPOOLF('FOR20','DAT',35)
08700	CCC  FOR INFO ON 'SPOOLF' SEE -- SPSUB[SPL,REG]
08800	63331	FORMAT(8F10.4)
08900	6333	FORMAT(I4,') ',A5,10F8.3)
09000		END
09100	
09200	C  THIS IS TO REPAIR DAMAGE DONE BY UNKNOWN BUGS!!!!
09300		SUBROUTINE FIXUP
09400		COMMON /XRN/RN(4000)/DL/X22,SAVER,NAME
09500		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/PTR/PWDS(250),ITEM,L,I,IX
09600		K=0
09700	2	K=K+1
09800	3	L=PWDS(K)
09900		RA=PWDS(K+1)
10000		RB=RN(L)+3.+L
10100	C  THIS SHOULD BE NEW POINTER
10200		IF(RA-RB.EQ.0)GO TO 6
10300	8	RJ=RA-L
10400		DO 9 JB=K+1,ITEM
10500	9	PWDS(JB)=PWDS(JB+1)-RJ
10600		TYPE 1,K
10700		J=RJ
10800		CALL LOOP(L,I,1,0,J,RN)
10900	C  REARRANGES DATA
11000		I=I-J
11100		ITEM=ITEM-1
11200		IF(ITEM.LE.K)GO TO 7
11300		GO TO 3
11400	C  GO BACK AND TRY AGAIN
11500	6	IF(RA.LE.L)GO TO 8
11600	C  JUMP IF PWDS IS OUT OF ORDER
11700		IF(K.LT.ITEM)GO TO 2
11800	7	SAVER=0
11900		CALL SAVIT
12000	1	FORMAT(' BAD ITEM--',I4/)
12100		END
12200	
12300	C   *******  7, POS,  STF, NUM OF SHARPS OR FLATS (+ OR -), CLEF, HGT
12400	C		      (	CLEF = TREB,0  BASS,1  ALT,2  TEN,3 )
12500		SUBROUTINE KSIG
12600	C   FOR KEY SIGNATURES AND ACCENTS, ETC. (IN 'SCORE')
12700		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/STF/RSTFAC(8),RSTJC
12800		EQUIVALENCE (RJD,RJQ(2)),(JD,JQ(2)),(JE,JQ(3)),(JF,JQ(4))
12900	
13000		JA=6
13100	C  USES THIS KEY NUM IN NOTWRT
13200		KN=0
13300	C   COUNTER
13400		IZ=IABS(JD)
13500	C  NUMBER OF CALLS ON NOTWRT
13700	C  THE CLEF NUM.  IT GETS WIPED OUT IN NOTWRT.
13800		JW=1
13900		IF(JD.GT.0)JW=2
14000	C   THE CODE FOR FLAT OR SHARP
14100	5333	CLEF=-(JE+1)
14200	C CLEF #S ARE CHNGD TO -1,-2,-3,-4 (TREB.,BA.,ALT.,TEN.)
14300	C  CLEF NOW SET IN MAIN PROG.
14400	C  IF NO CLEF GIVEN, TREBLE IS USED.
14600		T=10.
14700		IF(CLEF.LT.-2.)T=11.
14800		S=CLEF+4.
14900		IF(CLEF.EQ.-4)S=-1.
15000		IF(JD.LT.0)GO TO 253
15100		W=-3.
15200		YY=4.
15300		Z=11.
15400	C  SHARPS
15500		GO TO 353
15600	253	W=3.
15700		YY=-4.
15800		Z=7.
15900	C  FLATS
16000	353	N=1
16100		RX=JB
16200		RA=0
16300	C   RA IS AMOUNT TO BE ADDED TO ORIGINAL POS.
16400		DO 553 KA=1,IZ
16500		JE=JW
16600		JB=RX+RA
16700		RA=RA+13.*RSTJC
16800	C  MOVES OVER FOR NEXT ACCI.
16900		RD=Z
17000		RJD=Z
17100		IF(CLEF.NE.-1.)GO TO 7
17200		IF(RJD.GT.12.)RJD=RJD-7.
17300		GO TO 9
17400	7	RJD=RJD-S
17500		IF(RJD.GT.T)RJD=RJD-7.
17600	C  ABOVE ARRANGES VERT. POS OF ACCIS.
17700	9	JD=RJD
17800		CALL NOTWRT
17900		Z=RD+W
18000		IF(N)Z=RD+YY
18100	553	N=-N
18200		END